home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0887.arc / INDEX.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-06-23  |  4.3 KB  |  129 lines
  1. { INDEX.PAS in Turbo Pascal 3.0 for IBM PC and compatibles }
  2. { A book indexing program -- requires an input file -- execute as .COM }
  3. { Also requires a Boring Dictionary, BORING.DIC, in the .COM file's directory }
  4. { To execute .COM file, enter "index <inputfilename> <outputfilename> }
  5. program INDEX;
  6. const CR = #13;                  { carriage return character }
  7. const maxDict = 3750;     {maximum allowable dictionary entries}
  8. type letters  = 'a'..'z';
  9.      wordtype = string[16];
  10.      nodeptr  = ^nodetype;
  11.      nodetype = record
  12.           info: wordtype;
  13.           next: nodeptr
  14.         end;
  15. var inputFile,outputFile: text;
  16.     inputFilename, outputFilename: string[127];
  17.     chr,firstletter: char;
  18.     sortList: array[letters] of nodeptr;         { the array of 26 lists }
  19.     i: letters;
  20.     word: wordtype;
  21.     boringWords: array [1..maxDict] of wordtype;
  22.     dictionary : text;
  23.        endDict : integer;
  24. procedure InitFiles;
  25. begin           { open input and output files }
  26.   inputFilename := paramSTR(1);
  27.   Assign(inputFile,inputFilename);
  28.   Reset(inputFile);
  29.   outputFilename := paramSTR(2);
  30.   Assign(outputFile, outputFilename);
  31.   Rewrite(outputFile);
  32. end;
  33. procedure GetWord(VAR infile: text; VAR word: wordtype);
  34. begin           { read a cleaned-up word from the input file }
  35.   word := '';                           { initialize to blank }
  36.   repeat
  37.     read(infile,chr);
  38.     if chr in ['A'..'Z']              { convert all to lowercase }
  39.     then chr := char(ord(chr)+32);
  40.     if chr in ['a'..'z']              { only accept alpha characters }
  41.     then word := word+chr;               { add to word being built }
  42.   until (chr = ' ') or (chr = CR) or eof(infile)
  43. end;
  44. procedure Place(VAR list: nodeptr; word: wordtype);
  45. var p,q,newnode: nodeptr;
  46.     found: boolean;
  47. begin           { insert new word into list in sorted position only if unique }
  48.   q := nil;
  49.   p := list;                      { p points to head of list }
  50.   found := false;
  51.   while (p <> nil)                       { not end of list and }
  52.     and (not found)                 { word not already here and }
  53.     and (word >= p^.info) do        { word alphabetically later than current }
  54.     if p^.info = word              { does this node contain our word? }
  55.     then found := true                 { yes! word is already here }
  56.     else begin
  57.       q := p;                        { remember this node and }
  58.       p := p^.next                   { move on to the next one }
  59.     end; {while}
  60.   if not found                       { word isn't already here }
  61.   then begin
  62.     New(newnode);                     { create a new node }
  63.     newnode^.info := word;            { put word in its info field }
  64.     if q = nil                            { list was empty }
  65.     then begin
  66.       newnode^.next := list;                 { newnode becomes first }
  67.       list := newnode
  68.     end
  69.     else begin
  70.       newnode^.next := q^.next;                { insert after node q }
  71.       q^.next := newnode
  72.     end
  73.   end
  74. end;
  75. procedure SquirtOut(list: nodeptr; VAR outfile: text);
  76. begin           { send sorted list to output file }
  77.   while list <> nil
  78.   begin
  79.     writeln(outfile,list^.info);
  80.     list := list^.next
  81.   end
  82. end;
  83. procedure ReadDictionary;
  84. var i:integer;
  85. begin
  86.   Assign(dictionary,'BORING.DIC');
  87.   Reset(dictionary);
  88.   i := 1;
  89.   repeat
  90.     readln(dictionary,boringWords[i]);
  91.     i := i + 1
  92.     until eof(dictionary) or (i > maxDict);
  93.   endDict := i;       {number of actual dictionary entries}
  94. Close(dictionary)
  95. end;
  96. function Boring(word: wordtype): boolean;
  97. var left,right,try,svleft,svright: integer;
  98. begin
  99.   left := 1;
  100.   right := endDict;
  101.   repeat
  102.     svleft := left; svright := right;
  103.     try := (left + right) div 2;
  104.     if word < boringWords[try]
  105.       then right := try - 1
  106.       else left  := try + 1;
  107.     until (word = boringWords[try]) or (svleft > svright) ;
  108. if word = boringWords[try]
  109.     then Boring := true
  110.     else Boring := false
  111. end;
  112. begin           { main program }
  113.   InitFiles;
  114.   ReadDictionary;
  115.   for i := 'a' to 'z' do sortList[i] := nil;      { initialize all the lists }
  116.   while not eof(inputFile) do
  117.   begin
  118.     GetWord(inputFile,word);
  119.     firstletter := word[1];                  { get first letter }
  120.     if not Boring(word)
  121.       then Place(sortList[firstletter],word);      { put word in proper place }
  122.   end; {while}
  123.   for i := 'a' to 'z' do SquirtOut(sortList[i],outputFile);
  124.   writeln('Keywords are contained in ',outputFilename);
  125.   Close(inputFile);
  126.   Close(outputFile)
  127. end.
  128. List[i],outputFile);
  129.   wri